home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Toolbox Classes / readPort1 < prev    next >
Text File  |  1993-04-24  |  3KB  |  119 lines
  1. \ 6.10.87    rfl    modified to support backspace and paste
  2. \ 6.3.87    rfl Sends a text file to a Forth Board. Tabs are converted to
  3. \                spaces.
  4.  
  5. \ 4/19/87    rfl    removed most of switcher setup to relect telescope arch.
  6. \                this means no outputqueue and no polling
  7. \ 10.1.87    rfl added next: fevent to timeoutwait
  8. \ 10.8.87    rfl above fix caused problems with searcher on abort.... removed
  9. \ 1.1.88    rfl    general cleanup
  10. \ 6.22.88    rfl changed to class xPort for same methods to printer
  11. \ 7.1.88    rfl    took out next: fevent because of suspected problems with dlg
  12. \ 7.11.88    rfl    changed nullproc to assembly and took out pnullproc
  13. \ 9.17.88    rfl    remove link and endlink
  14. \ 8.13.90    rfl    modified term and removed ackword stuff
  15.  
  16. create nullProc $ 4e75 w,
  17.  
  18. 0 value charflag
  19. 0 variable theChar
  20.  
  21. :PROC doChr true -> charflag ;PROC
  22.  
  23. 'c dochr initproc
  24.  
  25. \ necessary to scroll since '13 emit' is not identical to 'cr'
  26. ( char -- )
  27. : .keys 4 tmode
  28.     CASE
  29.                 8 OF (bs) ENDOF
  30.                 0 12 RANGEOF ENDOF
  31.                 13  OF  cr ENDOF
  32.                 emit 0
  33.         ENDCASE 0 tmode ;
  34.  
  35. \ 0 variable ackWord  \ just a location to throw in acknowledgments
  36.  
  37. :CLASS ReadPort <super port
  38.  
  39.     timer    myTimer
  40.     int        TimeOutTime    \ a value of 4 is marginal, 5 seems to work ok
  41.     var        myAction
  42.     var        myNullProcCfa
  43.  
  44.   :M putTimeOut: put: timeOutTime ;M
  45.  
  46.   :M actions: put: myAction ;M
  47.  
  48.   :M putProc: put: myNullProcCfa ;M
  49.  
  50.   :M killRead: get: myNullProcCfa +base ^base 24 + ! kill: super drop ;M
  51.  
  52.   :M classInit: nullcfa put: myAction 6 put: timeOutTime ;M
  53.  
  54. \ waits for an acknowledge or times out. 'time' is in 60ths of a second
  55. \ returns non-zero if an error condition exists
  56.   :M timeOutWait: { time \ flag -- tf } 
  57.     start: myTimer false -> flag
  58.     BEGIN get: myTimer time >
  59.           IF  killread: self exec: myAction true -> flag THEN
  60. \          next: fevent IF 2drop THEN
  61.           result: self not 
  62.     UNTIL flag ;M
  63.  
  64. \ ( -- tf)
  65. \  :M waitForAck: get: myNullProcCfa
  66. \    ackword 1 readnw: self drop get: timeOutTime timeoutwait: self ;M
  67.  
  68.   :M term: { oPort \ myChar -- } 0 -> myChar 0 -> charflag
  69.         BEGIN result: self 0=
  70.             IF charFlag 0=
  71.                 IF 'c doChr theChar 1 readnw: self drop
  72.                 ELSE 0 -> charflag thechar c@ .keys
  73.                 THEN
  74.             ELSE result: self 0<
  75.                 IF result: self . abort" =read error" THEN
  76.             THEN
  77.             ?terminal
  78.             IF key -> myChar myChar ascii | <>
  79.                 IF myChar 8 =
  80.                     IF 127 ELSE myChar THEN
  81.                         put: oPort
  82.                 THEN
  83.             THEN
  84.             myChar ascii | =
  85.         UNTIL kill: self drop  ;M
  86.  
  87. ;CLASS
  88.  
  89. port iwout                port pwout
  90. 0 1 init: iwout            1 1 init: pwout
  91. 2 8 0 config: iwout        2 8 0 config: pwout
  92. 2400 baud: iwout        19200 baud: pwout
  93.  
  94. readPort iwin            \ instantiate input port
  95. 0 0 init: iwin            \ modem port
  96. 2 8 0 config: iwin        \ 2 stop, 8 data, no parity
  97. 2400 baud: iwin
  98. 'c nullProc putProc: iwin
  99.  
  100. ReadPort pwin            \ instantiate input port
  101. 1 0 init: pwin            \ printer port
  102. 2 8 0 config: pwin        \ 2 stop, 8 data, no parity
  103. 19200 baud: pwin
  104. 'c NullProc putProc: pwin
  105.  
  106.  
  107. : term  iwout term: iwin ;
  108. : pterm pwout term: pwin ;
  109.  
  110. : iOpen open: iwout open: iwin reset: iwin 2drop ;
  111. : pOpen open: pwout open: pwin reset: pwin 2drop ;
  112. : start iOpen pOpen ;
  113.  
  114.         
  115. : pWrite write: pwout drop ;
  116. : pWriteCr pWrite 13 put: pwout ;
  117. : crp 13 put: pwout ;
  118.  
  119.